home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 1997 #1 / Amiga Plus CD - 1997 - No. 01.iso / pd / programmierung / oberonv4 / demos / obtris.mod (.txt) < prev    next >
Oberon Text  |  1996-02-15  |  24KB  |  774 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10b.Scn.Fnt
  3. Syntax14b.Scn.Fnt
  4. FoldElems
  5. ParcElems
  6. Alloc
  7. MODULE ObTris; (** V1.0 (C) 1 Nov 1995 by Ralf Degner, E-Mail: degner@pallas.amp.uni-hannover.de *)
  8. (* If you use MacOberon or the Ceres replace Input.TimeUnit by 300 *)
  9. IMPORT
  10.     Oberon, Viewers, Display, MenuViewers, TextFrames, Texts, Files, Input;
  11. CONST
  12.     red=1; blue=3; green=2; yellow=4; col1=5; col2=6; col3=7;
  13.     Menu = "System.Close  System.Copy  System.Grow  ObTris.Start  ObTris.ShowNext  ObTris.Score";
  14.     XAnzahl=10; YAnzahl=24; MinKasten=4;
  15.     UntenOffset=10; ObenOffset=4; SeitenOffset=10; NextXPos=-5; NextYPos=YAnzahl DIV 2;
  16.     LinesProLevel=10; SpeedUpProLevel=20; ScoreFakt=10; ScoreFileMark=06C6F6976H;
  17.     String = ARRAY 32 OF CHAR;
  18.     Game = POINTER TO GameDesc;
  19.     GameDesc = RECORD
  20.         Field: ARRAY XAnzahl+2 OF ARRAY YAnzahl+2 OF INTEGER;
  21.         Runs, ShowNext: BOOLEAN;
  22.         Delay, Score, Level, Lines: LONGINT;
  23.         x, y, p, fig, next: INTEGER;
  24.     END;
  25.     Frame = POINTER TO FrameDesc;
  26.     FrameDesc = RECORD(Display.FrameDesc)
  27.         XOffset, YOffset: INTEGER;
  28.         Kasten: INTEGER;
  29.         Aktiv: BOOLEAN;
  30.         G: Game;
  31.     END;
  32.     ObTrisMsg = RECORD(Display.FrameMsg)
  33.     END;
  34.     DrawMsg = RECORD(ObTrisMsg)
  35.         G: Game;
  36.     END;
  37.     W: Texts.Writer;
  38.     Name: String;
  39.     Seed, Delay: LONGINT;
  40.     Fig: ARRAY 8 OF ARRAY 4 OF ARRAY 4 OF ARRAY 4 OF INTEGER;
  41.     FigSize: ARRAY 8 OF INTEGER;
  42.     HiScore, HiLevel, HiLines: ARRAY 10 OF LONGINT;
  43.     HiName: ARRAY 10 OF String;
  44.     ScoreFile: Files.File;
  45.     ScoreRider: Files.Rider;
  46.     ch: ARRAY 7 OF CHAR;
  47. (* Generate Random Numbers *)
  48. PROCEDURE Random(Ein: INTEGER):INTEGER;
  49.     CONST a=16807; m=2147483647; q=m DIV a; r=m MOD a;
  50.     VAR g: LONGINT;
  51. BEGIN
  52.     g:=a*(Seed MOD q)-r*(Seed DIV q);
  53.     IF g>0 THEN Seed:=g
  54.     ELSE Seed:=g+m END;
  55.     RETURN SHORT(Seed) MOD Ein
  56. END Random;
  57. (* Print current Keys *)
  58. PROCEDURE PrintKeys();
  59.     VAR d: INTEGER;
  60. BEGIN
  61.     Texts.WriteString(W, "Current Keys: ");
  62.     FOR d:=0 TO 5 DO
  63.         IF ch[d]=CHR(193) THEN Texts.WriteString(W, "UP")
  64.         ELSIF ch[d]=CHR(194) THEN Texts.WriteString(W, "DOWN")
  65.         ELSIF ch[d]=CHR(196) THEN Texts.WriteString(W, "LEFT")
  66.         ELSIF ch[d]=CHR(195) THEN Texts.WriteString(W, "RIGHT")
  67.         ELSIF ch[d]=CHR(13) THEN Texts.WriteString(W, "RETURN")
  68.         ELSIF ch[d]=CHR(27) THEN Texts.WriteString(W, "ESC")
  69.         ELSIF ch[d]=CHR(9) THEN Texts.WriteString(W, "TAB")
  70.         ELSIF ch[d]=" " THEN Texts.WriteString(W, "SPACE")
  71.         ELSE Texts.Write(W, ch[d]);
  72.         END;
  73.         Texts.Write(W, " ");
  74.     END;
  75.     Texts.WriteLn(W);
  76. END PrintKeys;
  77. (* Store HiScore *)
  78. PROCEDURE SaveHi(Register: BOOLEAN);
  79.     VAR d: INTEGER;
  80. BEGIN
  81.     Files.Set(ScoreRider, ScoreFile, 0);
  82.     Files.WriteLInt(ScoreRider, ScoreFileMark);
  83.     FOR d:=0 TO 5 DO
  84.         Files.Write(ScoreRider, ch[d])
  85.     END;
  86.     FOR d:=0 TO 9 DO
  87.         Files.WriteBytes(ScoreRider, HiName[d], 32);
  88.         Files.WriteLInt(ScoreRider, HiScore[d]);
  89.         Files.WriteLInt(ScoreRider, HiLevel[d]);
  90.         Files.WriteLInt(ScoreRider, HiLines[d]);
  91.     END;
  92.     IF Register THEN
  93.         Files.Register(ScoreFile)
  94.     ELSE
  95.          Files.Close(ScoreFile)
  96.      END
  97. END SaveHi;
  98. (* Load HiScore *)
  99. PROCEDURE LoadHi();
  100.         d: INTEGER;
  101.         m: LONGINT;
  102.     PROCEDURE ClearHi();
  103.         VAR n: INTEGER;
  104.     BEGIN
  105.         ch[0]:="j"; ch[1]:="k"; ch[2]:="i"; ch[3]:="m"; ch[4]:="h"; ch[5]:="p";
  106.         FOR n:=0 TO 9 DO
  107.             HiScore[n]:=0; HiLevel[n]:=0; HiLines[n]:=0;
  108.             COPY("Amiga", HiName[n])
  109.         END
  110.     END ClearHi;
  111. BEGIN
  112.     ScoreFile:=Files.Old("ObTris.Score");
  113.     IF ScoreFile=NIL THEN
  114.         ScoreFile:=Files.New("ObTris.Score");
  115.         ClearHi();
  116.         SaveHi(TRUE)
  117.     ELSE
  118.         Files.Set(ScoreRider, ScoreFile, 0);
  119.         Files.ReadLInt(ScoreRider, m);
  120.         IF m=ScoreFileMark THEN
  121.             FOR d:=0 TO 5 DO
  122.                 Files.Read(ScoreRider, ch[d])
  123.             END;
  124.             FOR d:=0 TO 9 DO
  125.                 Files.ReadBytes(ScoreRider, HiName[d], 32);
  126.                 Files.ReadLInt(ScoreRider, HiScore[d]);
  127.                 Files.ReadLInt(ScoreRider, HiLevel[d]);
  128.                 Files.ReadLInt(ScoreRider, HiLines[d])
  129.             END
  130.         ELSE
  131.             ClearHi();
  132.             SaveHi(FALSE)
  133.         END
  134. END LoadHi;
  135. (* New Score for Hall of Fame ? If Yes, Register *)
  136. PROCEDURE RegisterScore(s, le, li: LONGINT);
  137.     VAR d, n: LONGINT;
  138. BEGIN
  139.     d:=9;
  140.     WHILE (d#-1) & (HiScore[d]<s) DO DEC(d); END;
  141.     IF d#9 THEN
  142.         INC(d);
  143.         IF d<9 THEN
  144.             FOR n:=8 TO d BY -1 DO
  145.                 HiName[n+1]:=HiName[n]; HiScore[n+1]:=HiScore[n];
  146.                 HiLevel[n+1]:=HiLevel[n]; HiLines[n+1]:=HiLines[n]
  147.             END
  148.         END;
  149.         HiName[d]:=Name; HiScore[d]:=s;
  150.         HiLevel[d]:=le; HiLines[d]:=li;
  151.         Texts.WriteString(W, "Entering Hall of Fame ..."); Texts.WriteLn(W);
  152.         SaveHi(FALSE)
  153. END RegisterScore;
  154. (* Draw one Kasten *)
  155. PROCEDURE DrawKasten(f: Frame; x, y, Mode: INTEGER);
  156.     VAR XDum, YDum: INTEGER;
  157. BEGIN
  158.     XDum:=f.XOffset+(f.Kasten*(x-1));
  159.     YDum:=f.YOffset+(f.Kasten*(y-1));
  160.     Display.ReplConst(Display.white, XDum, YDum, f.Kasten-1, f.Kasten-1, Display.paint);
  161.     Display.ReplConst(Mode, XDum+1, YDum+1, f.Kasten-3, f.Kasten-3, Display.paint)
  162. END DrawKasten;
  163. (* Clear one Kasten *)
  164. PROCEDURE ClearKasten(f: Frame; x, y: INTEGER);
  165.     VAR XDum, YDum: INTEGER;
  166. BEGIN
  167.     XDum:=f.XOffset+(f.Kasten*(x-1));
  168.     YDum:=f.YOffset+(f.Kasten*(y-1));
  169.     Display.ReplConst(Display.black, XDum, YDum, f.Kasten-1, f.Kasten-1, Display.paint)
  170. END ClearKasten;
  171. (* Draw Figure *)
  172. PROCEDURE DrawFig(f: Frame; x, y, fi, pos: INTEGER);
  173.     VAR CountX, CountY, col: INTEGER;
  174. BEGIN
  175.     FOR CountX:= 0 TO 3 DO
  176.         FOR CountY:= 0 TO 3 DO
  177.             col:=Fig[fi, pos,CountX,CountY];
  178.             IF col#0 THEN DrawKasten(f, CountX+x, CountY+y, col) END
  179.         END
  180. END DrawFig;
  181. (* Clear Figure *)
  182. PROCEDURE ClearFig(f: Frame; x, y, fi, pos: INTEGER);
  183.     VAR CountX, CountY, col: INTEGER;
  184. BEGIN
  185.     FOR CountX:= 0 TO 3 DO
  186.         FOR CountY:= 0 TO 3 DO
  187.             col:=Fig[fi, pos,CountX,CountY];
  188.             IF col#0 THEN ClearKasten(f, CountX+x, CountY+y) END
  189.         END
  190. END ClearFig;
  191. (* Register Figure at Field *)
  192. PROCEDURE RegisterFig(G: Game; x, y, fi, pos: INTEGER);
  193.     VAR CX, CY, col: INTEGER;
  194. BEGIN
  195.     FOR CX:= 0 TO 3 DO
  196.         FOR CY:= 0 TO 3 DO
  197.             col:=Fig[fi, pos,CX,CY];
  198.             IF col#0 THEN G.Field[CX+x, CY+y]:=col END
  199.         END
  200. END RegisterFig;
  201. (* Test, if Figure fits to given Position *)
  202. PROCEDURE TestFig(G: Game; x, y, fi, pos: INTEGER): BOOLEAN;
  203.     VAR CountX, CountY, col: INTEGER;
  204. BEGIN
  205.     FOR CountX:= 0 TO 3 DO
  206.         FOR CountY:= 0 TO 3 DO
  207.             col:=Fig[fi, pos,CountX,CountY];
  208.             IF (col#0) & (G.Field[CountX+x, CountY+y]#0) THEN RETURN FALSE END
  209.         END
  210.     END;
  211.     RETURN TRUE;
  212. END TestFig;
  213. (* Calc Size of one Kasten, depending on Size of Frame *)
  214. PROCEDURE CalcKasten(f: Frame; x, y, w, h: INTEGER);
  215.     VAR XKasten, YKasten: INTEGER;
  216. BEGIN
  217.     f.Aktiv:=TRUE;
  218.     YKasten:=(h-ObenOffset-UntenOffset) DIV YAnzahl;
  219.     IF f.G.ShowNext THEN
  220.         XKasten:=(w-2*SeitenOffset) DIV (XAnzahl-NextXPos)
  221.     ELSE
  222.         XKasten:=(w-2*SeitenOffset) DIV XAnzahl;
  223.     END;
  224.     IF (XKasten<MinKasten) OR (YKasten<MinKasten) THEN
  225.         f.Aktiv:=FALSE;
  226.         RETURN;
  227.     END;
  228.     IF XKasten<YKasten THEN
  229.         f.Kasten:=XKasten
  230.     ELSE
  231.         f.Kasten:=YKasten;
  232.     END;
  233.     IF f.G.ShowNext THEN
  234.         f.XOffset:=x+(w-f.Kasten*(XAnzahl+NextXPos)) DIV 2
  235.     ELSE
  236.         f.XOffset:=x+(w-f.Kasten*XAnzahl) DIV 2;
  237.     END;
  238.     f.YOffset:=y+(h-f.Kasten*YAnzahl) DIV 2;
  239. END CalcKasten;
  240. (* Redraw Field *)
  241. PROCEDURE RedrawField(f: Frame);
  242.     VAR XD, YD: INTEGER;
  243. BEGIN
  244.     FOR YD:=1 TO YAnzahl DO
  245.         FOR XD:=1 TO XAnzahl DO
  246.             IF f.G.Field[XD, YD]=0 THEN
  247.                 ClearKasten(f, XD, YD)
  248.             ELSE
  249.                 DrawKasten(f, XD, YD, f.G.Field[XD, YD])
  250.             END
  251.         END
  252. END RedrawField;
  253. (* Search and Delete full Lines *)
  254. PROCEDURE KillLines(f: Frame);
  255.     VAR CountX, CountY, Killed: INTEGER;
  256.     PROCEDURE KillLine(VAR G: Game; l: INTEGER);
  257.         VAR CountX, CountY: INTEGER;
  258.     BEGIN
  259.         FOR CountY:=l+1 TO YAnzahl DO
  260.             FOR CountX:=1 TO XAnzahl DO
  261.                 G.Field[CountX, CountY-1]:=G.Field[CountX, CountY]
  262.             END
  263.         END;
  264.         FOR CountX:=1 TO XAnzahl DO
  265.             G.Field[CountX, YAnzahl]:=0
  266.         END
  267.     END KillLine;
  268. BEGIN
  269.     Killed:=0;
  270.     FOR CountY:=YAnzahl-1 TO 1 BY -1 DO
  271.         CountX:=1;
  272.         LOOP
  273.             IF f.G.Field[CountX, CountY]=0 THEN EXIT; END;
  274.             IF CountX=XAnzahl THEN
  275.                 INC(Killed);
  276.                 KillLine(f.G, CountY);
  277.                 EXIT;
  278.             END;
  279.             INC(CountX)
  280.         END
  281.     END;
  282.     IF Killed#0 THEN
  283.         RedrawField(f);
  284.         f.G.Lines:=f.G.Lines+Killed;
  285.         f.G.Score:=Killed*2-1+f.G.Score
  286.     END;
  287.     IF (f.G.Lines DIV LinesProLevel)>f.G.Level THEN
  288.         INC(f.G.Level); INC(f.G.Score, LinesProLevel DIV 2);
  289.         f.G.Delay:=(f.G.Delay * (100-SpeedUpProLevel)) DIV 100
  290. END KillLines;
  291. (* Clear Field *)
  292. PROCEDURE ClearField(G: Game);
  293.     VAR XDum, YDum: INTEGER;
  294. BEGIN
  295.     FOR XDum:= 1 TO XAnzahl DO
  296.         FOR YDum:=1 TO YAnzahl  DO
  297.             G.Field[XDum, YDum]:=0
  298.         END
  299.     END;
  300.     FOR YDum:=0 TO YAnzahl DO
  301.         G.Field[0, YDum]:=1;
  302.         G.Field[XAnzahl+1, YDum]:=1;
  303.     END;
  304.     FOR XDum:=0 TO XAnzahl+1 DO
  305.         G.Field[XDum, 0]:=1;
  306.         G.Field[XDum, YAnzahl+1]:=1
  307. END ClearField;
  308. (* Clear Frame and Draw everything necessary *)
  309. PROCEDURE ClearFrame(f: Frame; x, y, w, h: INTEGER);
  310.     VAR XDum, YDum: INTEGER;
  311. BEGIN
  312.     Oberon.RemoveMarks(x, y, w, h);
  313.     Display.ReplConst(Display.black, x, y, w, h, Display.paint);
  314.     IF f.Aktiv THEN
  315.         XDum:=f.Kasten*XAnzahl+1;
  316.         YDum:=f.Kasten*YAnzahl;
  317.         Display.ReplConst(Display.white, f.XOffset-3, f.YOffset-3, XDum+4, YDum+3, Display.paint);
  318.         Display.ReplConst(Display.black, f.XOffset-1, f.YOffset-1, XDum, YDum+1, Display.paint);
  319.         IF f.G.ShowNext THEN
  320.             XDum:=f.XOffset+f.Kasten*NextXPos-3;
  321.             YDum:=f.YOffset+f.Kasten*NextYPos-3;
  322.             Display.ReplConst(Display.white, XDum, YDum, 4*f.Kasten+5, 2*f.Kasten+5, Display.paint);
  323.             Display.ReplConst(Display.black, XDum+2, YDum+2, 4*f.Kasten+1, 2*f.Kasten+1, Display.paint);
  324.         END;
  325.         RedrawField(f);
  326.         IF f.G.Runs THEN
  327.             DrawFig(f, f.G.x, f.G.y, f.G.fig, f.G.p);
  328.             IF f.G.ShowNext THEN DrawFig(f, NextXPos+1, NextYPos+1, f.G.next, 0) END
  329.         END
  330. END ClearFrame;
  331. (* copy frame with same data *)
  332. PROCEDURE CopyMe(f: Frame): Frame;
  333.     VAR nf: Frame;
  334. BEGIN
  335.     NEW(nf);IF nf=NIL THEN RETURN NIL;END;
  336.     nf.handle:=f.handle;
  337.     nf.G:=f.G;
  338.     RETURN nf;
  339. END CopyMe;
  340. (* Open MenuFrame with ObTris.Menu.Text *)
  341. PROCEDURE MenuFrame(): TextFrames.Frame;
  342.         mf: TextFrames.Frame;
  343.         buf: Texts.Buffer;
  344.         t: Texts.Text;
  345.         r: Texts.Reader;
  346.         end: LONGINT;
  347.         ch: CHAR;
  348. BEGIN
  349.     IF Files.Old("ObTris.Menu.Text")=NIL THEN
  350.         mf:=TextFrames.NewMenu("ObTris", Menu)
  351.     ELSE
  352.         mf:=TextFrames.NewMenu("ObTris", "");
  353.         NEW(t);Texts.Open(t, "ObTris.Menu.Text");
  354.         Texts.OpenReader(r, t, 0);
  355.         REPEAT
  356.             Texts.Read(r, ch)
  357.         UNTIL r.eot OR (ch=0DX);
  358.         IF r.eot THEN
  359.             end:=t.len
  360.         ELSE
  361.             end:=Texts.Pos(r)-1;
  362.         END;
  363.         NEW(buf); Texts.OpenBuf(buf);
  364.         Texts.Save(t, 0, end, buf);Texts.Append(mf.text, buf)
  365.     END;
  366.     RETURN mf;
  367. END MenuFrame;
  368. (* Open new Text-Frame *)
  369. PROCEDURE OpenViewer(text: Texts.Text);
  370.     VAR x, y: INTEGER; v: Viewers.Viewer; cf: TextFrames.Frame;
  371. BEGIN
  372.     Oberon.AllocateSystemViewer(Oberon.Par.vwr.X, x, y);
  373.     cf := TextFrames.NewText(text, 0);
  374.     v := MenuViewers.New(TextFrames.NewMenu("ObTris Hall of Fame", "System.Close  System.Copy  System.Grow"),
  375.                                         cf, TextFrames.menuH, x, y)
  376. END OpenViewer;
  377. (* Handler of an ObTris Frame *)
  378. PROCEDURE Handler(f: Display.Frame; VAR m: Display.FrameMsg);
  379.     VAR self: Frame;
  380. BEGIN
  381.     self:=f(Frame);
  382.     WITH m: Oberon.InputMsg DO
  383.         IF m.id=Oberon.track THEN Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, m.X, m.Y) END
  384.     | m: Oberon.CopyMsg DO
  385.         m.F:=CopyMe(self)
  386.     | m: MenuViewers.ModifyMsg DO
  387.         WITH m: MenuViewers.ModifyMsg DO
  388.             IF m.H#0 THEN
  389.                 CalcKasten(self, f.X, m.Y, f.W, m.H);
  390.                 ClearFrame(self, f.X, m.Y, f.W, m.H)
  391.             END
  392.         END
  393.     | m: ObTrisMsg DO
  394.         WITH m: DrawMsg DO
  395.             IF m.G=self.G THEN
  396.                 CalcKasten(self, f.X, f.Y, f.W, f.H);
  397.                 ClearFrame(self, f.X, f.Y, f.W, f.H)
  398.             END
  399.         ELSE
  400.         END
  401.     ELSE
  402. END Handler;
  403. (* get current/marked Frame *)
  404. PROCEDURE GetFrame(VAR f: Display.Frame): BOOLEAN;
  405.     VAR v: Viewers.Viewer;
  406. BEGIN
  407.     IF Oberon.Par.frame=Oberon.Par.vwr.dsc THEN
  408.         IF (Oberon.Par.frame # NIL) THEN
  409.             f:=Oberon.Par.frame.next;
  410.             RETURN TRUE
  411.         END
  412.     ELSE
  413.         v:=Oberon.MarkedViewer();
  414.         IF (v.dsc # NIL) & (v.dsc.next # NIL) THEN
  415.             f:=v.dsc.next;
  416.             RETURN TRUE
  417.         END
  418.     END;
  419.     RETURN FALSE;
  420. END GetFrame;
  421. (* Calc System Speed *)
  422. PROCEDURE CalcSysSpeed(): LONGINT;
  423.         EndTime, Time, StartTime, q, Anz: LONGINT;
  424.         c: CHAR;
  425.         f: Frame;
  426.         x, y, fig, p, d: INTEGER;
  427. BEGIN
  428.     NEW(f);x:=0; y:=0; fig:=0; p:=0; Anz:=0;
  429.     StartTime:=Input.Time(); ch[6]:=CHR(0);
  430.     EndTime:=StartTime+Input.TimeUnit; (* replace Input.TimeUnit by 300 at MacOberon and Ceres *)
  431.     REPEAT
  432.         FOR q:=0 TO 31 DO
  433.             IF Input.Available()>0 THEN
  434.                 Input.Read(c);
  435.                 IF (c=ch[6]) OR (CAP(c)="P") THEN
  436.                 ELSIF c=ch[6] THEN
  437.                     IF TestFig(f.G, x-1, y, fig, p) THEN
  438.                         ClearFig(f, x, y, fig, p);
  439.                         DEC(x);
  440.                         DrawFig(f, x, y, fig, p)
  441.                     END
  442.                 ELSIF c=ch[6] THEN
  443.                     IF TestFig(f.G, x+1, y, fig, p) THEN
  444.                         ClearFig(f, x, y, fig, p);
  445.                         INC(x);
  446.                         DrawFig(f, x, y, fig, p)
  447.                     END
  448.                 ELSIF c=ch[6] THEN
  449.                     d:=p+1; IF d=4 THEN d:=0; END;
  450.                     IF TestFig(f.G, x, y, fig, d) THEN
  451.                         ClearFig(f, x, y, fig, p);
  452.                         DrawFig(f, x, y, fig, d);
  453.                         p:=d
  454.                     END
  455.                 ELSIF c=ch[6] THEN
  456.                     d:=p-1; IF d=-1 THEN d:=3; END;
  457.                     IF TestFig(f.G, x, y, fig, d) THEN
  458.                         ClearFig(f, x, y, fig, p);
  459.                         DrawFig(f, x, y, fig, d);
  460.                         p:=d
  461.                     END
  462.                 ELSIF c=ch[6] THEN
  463.                     d:=y;
  464.                     WHILE TestFig(f.G, x, y-1, fig, p) DO DEC(y); END;
  465.                     ClearFig(f, x, d, fig, p);
  466.                     DrawFig(f, x, y, fig, p)
  467.                 END
  468.             END
  469.         END;
  470.         INC(Anz, 31);
  471.         Time:=Input.Time()
  472.     UNTIL Time>=EndTime;
  473.     RETURN (Anz*(EndTime-StartTime)) DIV Input.TimeUnit; (* replace Input.TimeUnit by 300 at MacOberon and Ceres *)
  474. END CalcSysSpeed;
  475. (* Main-Loop of the Game *)
  476. PROCEDURE GameLoop(f: Frame);
  477.         c: CHAR;
  478.         DelCount: LONGINT;
  479.         x, y, p, fig, next, d: INTEGER;
  480.         msg: DrawMsg;
  481. BEGIN
  482.     x:=f.G.x; y:=f.G.y; p:=f.G.p; fig:=f.G.fig; next:=f.G.next;
  483.     f.G.Runs:=TRUE;
  484.     Oberon.RemoveMarks(f.X, f.Y, f.W, f.H);
  485.     IF f.G.ShowNext THEN DrawFig(f, NextXPos+1, NextYPos+1, next, 0); END;
  486.     LOOP
  487.         IF TestFig(f.G, x, y-1, fig, p) THEN
  488.             ClearFig(f, x, y, fig, p);
  489.             DEC(y);
  490.             DrawFig(f, x, y, fig, p)
  491.         ELSE
  492.             RegisterFig(f.G, x, y, fig, p);
  493.             KillLines(f);
  494.             y:=YAnzahl-2; p:=0; fig:=next; next:=Random(7); x:=((XAnzahl-FigSize[fig]) DIV 2)+1;
  495.             IF fig=1 THEN DEC(y); p:=2; END;
  496.             IF ~TestFig(f.G, x, y, fig, p) THEN f.G.Runs:=FALSE; EXIT END;
  497.             IF f.G.ShowNext THEN
  498.                 ClearFig(f, NextXPos+1, NextYPos+1, fig, 0);
  499.                 DrawFig(f, NextXPos+1, NextYPos+1, next, 0);
  500.             END;
  501.             DrawFig(f, x, y, fig, p);
  502.         END;
  503.         FOR DelCount:=0 TO f.G.Delay DO
  504.             IF Input.Available()>0 THEN
  505.                 Input.Read(c);
  506.                 IF (c=ch[5]) OR (CAP(c)="P") THEN EXIT
  507.                 ELSIF c=ch[0] THEN
  508.                     IF TestFig(f.G, x-1, y, fig, p) THEN
  509.                         ClearFig(f, x, y, fig, p);
  510.                         DEC(x);
  511.                         DrawFig(f, x, y, fig, p)
  512.                     END
  513.                 ELSIF c=ch[1] THEN
  514.                     IF TestFig(f.G, x+1, y, fig, p) THEN
  515.                         ClearFig(f, x, y, fig, p);
  516.                         INC(x);
  517.                         DrawFig(f, x, y, fig, p)
  518.                     END
  519.                 ELSIF (c=ch[2]) & (x#-1) THEN
  520.                     d:=p+1; IF d=4 THEN d:=0; END;
  521.                     IF TestFig(f.G, x, y, fig, d) THEN
  522.                         ClearFig(f, x, y, fig, p);
  523.                         DrawFig(f, x, y, fig, d);
  524.                         p:=d
  525.                     END
  526.                 ELSIF (c=ch[3]) & (x#-1) THEN
  527.                     d:=p-1; IF d=-1 THEN d:=3; END;
  528.                     IF TestFig(f.G, x, y, fig, d) THEN
  529.                         ClearFig(f, x, y, fig, p);
  530.                         DrawFig(f, x, y, fig, d);
  531.                         p:=d
  532.                     END
  533.                 ELSIF c=ch[4] THEN
  534.                     d:=y;
  535.                     WHILE TestFig(f.G, x, y-1, fig, p) DO DEC(y); END;
  536.                     ClearFig(f, x, d, fig, p);
  537.                     DrawFig(f, x, y, fig, p)
  538.                 END
  539.             END
  540.         END
  541.     END;
  542.     IF f.G.Runs THEN
  543.         f.G.x:=x; f.G.y:=y; f.G.p:=p; f.G.fig:=fig; f.G.next:=next;
  544.         Texts.WriteString(W, "Current ObTris Status -")
  545.     ELSE
  546.         Texts.WriteString(W, "--- GAME OVER ---   ");
  547.         RegisterScore(f.G.Score, f.G.Level, f.G.Lines);
  548.     END;
  549.     Texts.WriteString(W, " Score: ");
  550.     Texts.WriteInt(W, f.G.Score*ScoreFakt, 1);
  551.     Texts.WriteString(W, "  Lines: ");
  552.     Texts.WriteInt(W, f.G.Lines, 1);
  553.     Texts.WriteString(W, "  Level: ");
  554.     Texts.WriteInt(W, f.G.Level, 1);
  555.     Texts.WriteLn(W);
  556.     Texts.Append(Oberon.Log, W.buf);
  557.     msg.G:=f.G; Viewers.Broadcast(msg);
  558. END GameLoop;
  559. (* Start New Game *)
  560. PROCEDURE StartNewGame(g: Frame);
  561.     VAR msg: DrawMsg;
  562. BEGIN
  563.     IF g.Aktiv THEN
  564.         g.G.Delay:=Delay;
  565.         ClearField(g.G);
  566.         g.G.y:=YAnzahl-2; g.G.p:=0; g.G.fig:=Random(7); g.G.next:=Random(7);
  567.         g.G.Lines:=0; g.G.Score:=0; g.G.Level:=0; g.G.x:=((XAnzahl-FigSize[g.G.fig]) DIV 2)+1;
  568.         IF g.G.fig=1 THEN DEC(g.G.y); g.G.p:=2; END;
  569.         msg.G:=g.G; Viewers.Broadcast(msg);
  570.         GameLoop(g)
  571. END StartNewGame;
  572. (* Open new ObTris Frame *)
  573. PROCEDURE Open*();
  574.         f: Frame;
  575.         v: MenuViewers.Viewer;
  576.         x, y: INTEGER;
  577. BEGIN
  578.     NEW(f); NEW(f.G); f.G.ShowNext:=TRUE; f.Aktiv:=FALSE;
  579.     f.handle:=Handler;
  580.     Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  581.     v:=MenuViewers.New(MenuFrame(), f, TextFrames.menuH, x, y);
  582.     ClearField(f.G);
  583. END Open;
  584. (* Start New Game Command *)
  585. PROCEDURE StartNew*();
  586.     VAR f, g: Display.Frame;
  587. BEGIN
  588.     IF GetFrame(f) THEN
  589.         g:=f;
  590.         WITH g: Frame DO
  591.             StartNewGame(g)
  592.         ELSE
  593.         END
  594. END StartNew;
  595. (* Restart Game or Start New *)
  596. PROCEDURE Start*();
  597.     VAR f, g: Display.Frame;
  598. BEGIN
  599.     IF GetFrame(f) THEN
  600.         g:=f;
  601.         WITH g: Frame DO
  602.             IF g.Aktiv THEN
  603.                 IF g.G.Runs THEN
  604.                     GameLoop(g)
  605.                 ELSE
  606.                     StartNewGame(g)
  607.                 END
  608.             END
  609.         ELSE
  610.         END
  611. END Start;
  612. (* Restart Game or Start New *)
  613. PROCEDURE ShowNext*();
  614.         f, g: Display.Frame;
  615.         msg: DrawMsg;
  616. BEGIN
  617.     IF GetFrame(f) THEN
  618.         g:=f;
  619.         WITH g: Frame DO
  620.             g.G.ShowNext:=~g.G.ShowNext;
  621.             msg.G:=g.G; Viewers.Broadcast(msg)
  622.         ELSE
  623.         END
  624. END ShowNext;
  625. (* set new username *)
  626. PROCEDURE SetUser*;
  627.         S: Texts.Scanner;
  628.         text: Texts.Text;
  629.         beg, end, time: LONGINT;
  630. BEGIN
  631.     Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
  632.     Texts.Scan(S);
  633.     IF S.class=Texts.Char THEN
  634.         IF S.c="^" THEN
  635.             Oberon.GetSelection(text, beg, end, time);
  636.             IF time=-1 THEN RETURN; END;
  637.             Texts.OpenScanner(S, text, beg);
  638.             Texts.Scan(S)
  639.         ELSE
  640.             RETURN
  641.         END
  642.     END;
  643.     IF S.class=Texts.Name THEN
  644.         COPY(S.s, Name);
  645.     END;
  646.     Texts.WriteString(W, "Current Username : ");
  647.     Texts.WriteString(W, Name);
  648.     Texts.WriteLn(W);
  649.     Texts.Append(Oberon.Log, W.buf);
  650. END SetUser;
  651. (* show Hi-Score *)
  652. PROCEDURE Score*;
  653.         i: INTEGER;
  654.         te: Texts.Text;
  655. BEGIN
  656.     NEW(te); te:=TextFrames.Text("");
  657.     IF Files.Old("ObTris.Score.Text")=NIL THEN
  658.         NEW(te); te:=TextFrames.Text("");
  659.         Texts.WriteString(W, "   Oberon-Tetris Hall Of Fame !   ");Texts.WriteLn(W);
  660.         Texts.WriteString(W, "______________________________________________________");Texts.WriteLn(W)
  661.     ELSE
  662.         Texts.Open(te, "ObTris.Score.Text");
  663.     END;
  664.     FOR i:=0 TO 9 DO
  665.         Texts.WriteInt(W, i+1, 1); Texts.Write(W, CHR(9));
  666.         Texts.WriteString(W, HiName[i]); Texts.Write(W, CHR(9));
  667.         Texts.WriteInt(W, HiScore[i]*ScoreFakt, 1); Texts.Write(W, CHR(9));
  668.         Texts.WriteInt(W, HiLevel[i], 1); Texts.Write(W, CHR(9));
  669.         Texts.WriteInt(W, HiLines[i], 1);
  670.         Texts.WriteLn(W);
  671.     END;
  672.     Texts.WriteLn(W);
  673.     Texts.WriteString(W, "Current Username : ");
  674.     Texts.WriteString(W, Name);
  675.     Texts.WriteLn(W); Texts.WriteLn(W);
  676.     PrintKeys();
  677.     Texts.Append(te, W.buf);
  678.     OpenViewer(te);
  679. END Score;
  680. (* set keys *)
  681. PROCEDURE SetKeys*;
  682.         S: Texts.Scanner;
  683.         text: Texts.Text;
  684.         d, beg, end, time: LONGINT;
  685.         c: ARRAY 6 OF CHAR;
  686. BEGIN
  687.     Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
  688.     Texts.Scan(S);
  689.     IF (S.class=Texts.Char) & (S.c="^") THEN
  690.         Oberon.GetSelection(text, beg, end, time);
  691.         IF time=-1 THEN RETURN; END;
  692.         Texts.OpenScanner(S, text, beg);
  693.         Texts.Scan(S)
  694.     END;
  695.     FOR d:=0 TO 5 DO
  696.         IF (S.class=Texts.Char) & (S.c#CHR(0)) THEN
  697.             c[d]:=S.c
  698.         ELSIF (S.class=Texts.Int) & (S.i>=0) & (S.i<=9) THEN
  699.             c[d]:=CHR(48+S.i)
  700.         ELSIF S.class=Texts.Name THEN
  701.             IF S.s="UP" THEN c[d]:=CHR(193)
  702.             ELSIF S.s="DOWN" THEN c[d]:=CHR(194)
  703.             ELSIF S.s="LEFT" THEN c[d]:=CHR(196)
  704.             ELSIF S.s="RIGHT" THEN c[d]:=CHR(195)
  705.             ELSIF S.s="RETURN" THEN c[d]:=CHR(13)
  706.             ELSIF S.s="TAB" THEN c[d]:=CHR(9)
  707.             ELSIF S.s="SPACE" THEN c[d]:=" "
  708.             ELSIF S.s="ESC" THEN c[d]:=CHR(27)
  709.             ELSE c[d]:=S.s[0]
  710.             END
  711.         ELSE
  712.             Texts.WriteString(W, "Wrong Key Or Not Enough Keys!");
  713.             Texts.Append(Oberon.Log, W.buf); RETURN
  714.         END;
  715.         Texts.Scan(S)
  716.     END;
  717.     FOR d:=0 TO 5 DO ch[d]:=c[d] END;
  718.     PrintKeys(); Texts.Append(Oberon.Log, W.buf);
  719.     SaveHi(FALSE);
  720. END SetKeys;
  721. (* Create all Figures in Fig *)
  722. PROCEDURE CreateFigures();
  723.     VAR a, p, x, y, s, d: INTEGER;
  724.     PROCEDURE ClearFig(fi, neu: INTEGER);
  725.     BEGIN
  726.         FOR x:=0 TO 3 DO
  727.             FOR y:=0 TO 3 DO
  728.                 Fig[fi, neu,x, y]:=0
  729.             END
  730.         END
  731.     END ClearFig;
  732. BEGIN
  733.     (* clear all Figures at Pos 0*)
  734.     FOR a:=0 TO 6 DO ClearFig(a, 0) END;
  735.     (* set Figures at Pos 1*)
  736.     FigSize[0]:=2; Fig[0,0,0,0]:=blue; Fig[0,0,1,0]:=blue; Fig[0,0,0,1]:=blue; Fig[0,0,1,1]:=blue;
  737.     FigSize[1]:=4; Fig[1,0,0,1]:=red; Fig[1,0,1,1]:=red; Fig[1,0,2,1]:=red; Fig[1,0,3,1]:=red;
  738.     FigSize[2]:=3; Fig[2,0,1,1]:=green; Fig[2,0,0,0]:=green; Fig[2,0,1,0]:=green; Fig[2,0,2,1]:=green;
  739.     FigSize[3]:=3; Fig[3,0,1,1]:=col1; Fig[3,0,0,1]:=col1; Fig[3,0,1,0]:=col1; Fig[3,0,2,0]:=col1;
  740.     FigSize[4]:=3; Fig[4,0,1,1]:=yellow; Fig[4,0,0,0]:=yellow; Fig[4,0,0,1]:=yellow; Fig[4,0,2,1]:=yellow;
  741.     FigSize[5]:=3; Fig[5,0,1,1]:=col2; Fig[5,0,2,0]:=col2; Fig[5,0,0,1]:=col2; Fig[5,0,2,1]:=col2;
  742.     FigSize[6]:=3; Fig[6,0,1,1]:=col3; Fig[6,0,1,0]:=col3; Fig[6,0,0,1]:=col3; Fig[6,0,2,1]:=col3;
  743.     (* generate rotated Figures *)
  744.     FOR a:=0 TO 6 DO
  745.         FOR p:=1 TO 3 DO
  746.             s:=FigSize[a]-1;
  747.             IF (s=1) OR (s=2) THEN ClearFig(a, p); END;
  748.             FOR x:=0 TO s DO
  749.                 FOR y:=0 TO s DO
  750.                     d:=Fig[a, p-1, x, y];
  751.                     Fig[a, p, s-y, x]:=d
  752.                 END
  753.             END
  754.         END
  755. END CreateFigures;
  756. BEGIN
  757.     Texts.OpenWriter(W);
  758.     Texts.WriteString(W, "ObTris (Oberon-Tetris) V1.0");
  759.     Texts.WriteLn(W);
  760.     Texts.WriteString(W, "(C) 1 Nov 1995 by Ralf Degner");
  761.     Texts.WriteLn(W);
  762.     Texts.Append(Oberon.Log, W.buf);
  763.     IF Oberon.User="" THEN
  764.         Name:="AMIGA"
  765.     ELSE
  766.         COPY(Oberon.User, Name);
  767.     END;
  768.     Delay:=CalcSysSpeed();
  769.     CreateFigures();
  770.     LoadHi();
  771.     Seed:=Input.Time();
  772. END ObTris.Open
  773. System.Free ObTris ~
  774.